home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-page.el.z / vm-page.el
Encoding:
Text File  |  1998-05-21  |  25.4 KB  |  730 lines
  1. ;;; Commands to move around within a VM message
  2. ;;; Copyright (C) 1989-1997 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-page)
  19.  
  20. (defun vm-scroll-forward (&optional arg)
  21.   "Scroll forward a screenful of text.
  22. If the current message is being previewed, the message body is revealed.
  23. If at the end of the current message, moves to the next message iff the
  24. value of vm-auto-next-message is non-nil.
  25. Prefix argument N means scroll forward N lines."
  26.   (interactive "P")
  27.   (let ((mp-changed (vm-follow-summary-cursor))
  28.     needs-decoding 
  29.     (was-invisible nil))
  30.     (vm-select-folder-buffer)
  31.     (vm-check-for-killed-summary)
  32.     (vm-check-for-killed-presentation)
  33.     (vm-error-if-folder-empty)
  34.     (setq needs-decoding (and vm-display-using-mime
  35.                   (not vm-mime-decoded)
  36.                   (not (vm-mime-plain-message-p
  37.                     (car vm-message-pointer)))
  38.                   vm-auto-decode-mime-messages
  39.                   (eq vm-system-state 'previewing)))
  40.     (and vm-presentation-buffer
  41.      (set-buffer vm-presentation-buffer))
  42.     (let ((point (point))
  43.       (w (vm-get-visible-buffer-window (current-buffer))))
  44.       (if (or (null w)
  45.           (not (vm-frame-totally-visible-p (vm-window-frame w))))
  46.       (progn
  47.         (vm-display (current-buffer) t
  48.             '(vm-scroll-forward vm-scroll-backward)
  49.             (list this-command 'reading-message))
  50.         ;; window start sticks to end of clip region when clip
  51.         ;; region moves back past it in the buffer.  fix it.
  52.         (setq w (vm-get-visible-buffer-window (current-buffer)))
  53.         (if (= (window-start w) (point-max))
  54.         (set-window-start w (point-min)))
  55.         (setq was-invisible t))))
  56.     (if (or mp-changed was-invisible needs-decoding
  57.         (and (eq vm-system-state 'previewing)
  58.          (pos-visible-in-window-p
  59.           (point-max)
  60.           (vm-get-visible-buffer-window (current-buffer)))))
  61.     (progn
  62.       (if (not was-invisible)
  63.           (let ((w (vm-get-visible-buffer-window (current-buffer)))
  64.             old-w-start)
  65.         (setq old-w-start (window-start w))
  66.         (vm-display nil nil '(vm-scroll-forward vm-scroll-backward)
  67.                 (list this-command 'reading-message))
  68.         (setq w (vm-get-visible-buffer-window (current-buffer)))
  69.         (and w (set-window-start w old-w-start))))
  70.       (if (eq vm-system-state 'previewing)
  71.           (vm-show-current-message))
  72.       (vm-howl-if-eom))
  73.       (let ((vmp vm-message-pointer)
  74.         (msg-buf (current-buffer))
  75.         (h-diff 0)
  76.         w old-w old-w-height old-w-start result)
  77.     (if (eq vm-system-state 'previewing)
  78.         (vm-show-current-message))
  79.     (setq vm-system-state 'reading)
  80.     (setq old-w (vm-get-visible-buffer-window msg-buf)
  81.           old-w-height (window-height old-w)
  82.           old-w-start (window-start old-w))
  83.     (vm-display nil nil '(vm-scroll-forward vm-scroll-backward)
  84.             (list this-command 'reading-message))
  85.     (setq w (vm-get-visible-buffer-window msg-buf))
  86.     (if (null w)
  87.         (error "current window configuration hides the message buffer.")
  88.       (setq h-diff (- (window-height w) old-w-height)))
  89.     ;; must restore this since it gets clobbered by window
  90.     ;; teardown and rebuild done by the window config stuff.
  91.     (set-window-start w old-w-start)
  92.     (setq old-w (selected-window))
  93.     (unwind-protect
  94.         (progn
  95.           (select-window w)
  96.           (let ((next-screen-context-lines
  97.              (+ next-screen-context-lines h-diff)))
  98.         (while (eq (setq result (vm-scroll-forward-internal arg))
  99.                'tryagain))
  100.         (cond ((and (not (eq result 'next-message))
  101.                 vm-honor-page-delimiters)
  102.                (vm-narrow-to-page)
  103.                ;; This voodoo is required!  For some
  104.                ;; reason the 18.52 emacs display
  105.                ;; doesn't immediately reflect the
  106.                ;; clip region change that occurs
  107.                ;; above without this mantra. 
  108.                (scroll-up 0)))))
  109.       (select-window old-w))
  110.     (set-buffer msg-buf)
  111.     (cond ((eq result 'next-message)
  112.            (vm-next-message))
  113.           ((eq result 'end-of-message)
  114.            (let ((vm-message-pointer vmp))
  115.          (vm-emit-eom-blurb)))
  116.           (t
  117.            (and (> (prefix-numeric-value arg) 0)
  118.             (vm-howl-if-eom)))))))
  119.   (if (not vm-startup-message-displayed)
  120.       (vm-display-startup-message)))
  121.  
  122. (defun vm-scroll-forward-internal (arg)
  123.   (let ((direction (prefix-numeric-value arg))
  124.     (w (selected-window)))
  125.     (condition-case error-data
  126.     (progn (scroll-up arg) nil)
  127. ;; this looks like it should work, but doesn't because the
  128. ;; redisplay code is schizophrenic when it comes to updates.  A
  129. ;; window position may no longer be visible but
  130. ;; pos-visible-in-window-p will still say it is because it was
  131. ;; visible before some window size change happened.
  132. ;;    (progn
  133. ;;      (if (and (> direction 0)
  134. ;;           (pos-visible-in-window-p
  135. ;;            (vm-text-end-of (car vm-message-pointer))))
  136. ;;          (signal 'end-of-buffer nil)
  137. ;;        (scroll-up arg))
  138. ;;      nil )
  139.       (error
  140.        (if (or (and (< direction 0)
  141.             (> (point-min) (vm-text-of (car vm-message-pointer))))
  142.            (and (>= direction 0)
  143.             (/= (point-max)
  144.             (vm-text-end-of (car vm-message-pointer)))))
  145.        (progn
  146.          (vm-widen-page)
  147.          (if (>= direction 0)
  148.          (progn
  149.            (forward-page 1)
  150.            (set-window-start w (point))
  151.            nil )
  152.            (if (or (bolp)
  153.                (not (save-excursion
  154.                   (beginning-of-line)
  155.                   (looking-at page-delimiter))))
  156.            (forward-page -1))
  157.            (beginning-of-line)
  158.            (set-window-start w (point))
  159.            'tryagain))
  160.      (if (eq (car error-data) 'end-of-buffer)
  161.          (if vm-auto-next-message
  162.          'next-message
  163.            (set-window-point w (point))
  164.            'end-of-message)))))))
  165.  
  166. ;; exploratory scrolling, what a concept.
  167. ;;
  168. ;; we do this because pos-visible-in-window-p checks the current
  169. ;; window configuration, while this exploratory scrolling forces
  170. ;; Emacs to recompute the display, giving us an up to the moment
  171. ;; answer about where the end of the message is going to be
  172. ;; visible when redisplay finally does occur.
  173. (defun vm-howl-if-eom ()
  174.   (let ((w (get-buffer-window (current-buffer))))
  175.     (and w
  176.      (save-excursion
  177.        (save-window-excursion
  178.          (condition-case ()
  179.          (let ((next-screen-context-lines 0))
  180.            (select-window w)
  181.            (save-excursion
  182.              (save-window-excursion
  183.                ;; scroll-fix.el replaces scroll-up and
  184.                ;; doesn't behave properly when it hits
  185.                ;; end of buffer.  It does this!
  186.                ;; (ding)
  187.                ;; (message (get 'beginning-of-buffer 'error-message))
  188.                (let ((scroll-in-place-replace-original nil))
  189.              (scroll-up nil))))
  190.            nil)
  191.            (error t))))
  192.      (= (vm-text-end-of (car vm-message-pointer)) (point-max))
  193.      (vm-emit-eom-blurb))))
  194.  
  195. (defun vm-emit-eom-blurb ()
  196.   (if (vm-full-name-of (car vm-message-pointer))
  197.       (message "End of message %s from %s"
  198.               (vm-number-of (car vm-message-pointer))
  199.               (vm-full-name-of (car vm-message-pointer)))
  200.     (message "End of message %s"
  201.             (vm-number-of (car vm-message-pointer)))))
  202.  
  203. (defun vm-scroll-backward (&optional arg)
  204.   "Scroll backward a screenful of text.
  205. Prefix N scrolls backward N lines."
  206.   (interactive "P")
  207.   (vm-scroll-forward (cond ((null arg) '-)
  208.                ((consp arg) (list (- (car arg))))
  209.                ((numberp arg) (- arg))
  210.                ((symbolp arg) nil)
  211.                (t arg))))
  212.  
  213. (defun vm-highlight-headers ()
  214.   (cond
  215.    ((and vm-xemacs-p vm-use-lucid-highlighting)
  216.     (require 'highlight-headers)
  217.     ;; disable the url marking stuff, since VM has its own interface.
  218.     (let ((highlight-headers-mark-urls nil)
  219.       (highlight-headers-regexp (or vm-highlighted-header-regexp
  220.                     highlight-headers-regexp)))
  221.       (highlight-headers (point-min) (point-max) t)))
  222.    (vm-xemacs-p
  223.     (let (e)
  224.       (map-extents (function
  225.             (lambda (e ignore)
  226.               (if (extent-property e 'vm-highlight)
  227.               (delete-extent e))
  228.               nil))
  229.            (current-buffer) (point-min) (point-max))
  230.       (goto-char (point-min))
  231.       (while (vm-match-header)
  232.     (cond ((vm-match-header vm-highlighted-header-regexp)
  233.            (setq e (make-extent (vm-matched-header-contents-start)
  234.                     (vm-matched-header-contents-end)))
  235.            (set-extent-property e 'face vm-highlighted-header-face)
  236.            (set-extent-property e 'vm-highlight t)))
  237.     (goto-char (vm-matched-header-end)))))
  238.    ((fboundp 'overlay-put)
  239.     (let (o-lists p)
  240.       (setq o-lists (overlay-lists)
  241.         p (car o-lists))
  242.       (while p
  243.     (and (overlay-get (car p) 'vm-highlight)
  244.          (delete-overlay (car p)))
  245.     (setq p (cdr p)))
  246.       (setq p (cdr o-lists))
  247.       (while p
  248.     (and (overlay-get (car p) 'vm-highlight)
  249.          (delete-overlay (car p)))
  250.     (setq p (cdr p)))
  251.       (goto-char (point-min))
  252.       (while (vm-match-header)
  253.     (cond ((vm-match-header vm-highlighted-header-regexp)
  254.            (setq p (make-overlay (vm-matched-header-contents-start)
  255.                      (vm-matched-header-contents-end)))
  256.            (overlay-put p 'face vm-highlighted-header-face)
  257.            (overlay-put p 'vm-highlight t)))
  258.     (goto-char (vm-matched-header-end)))))))
  259.  
  260. (defun vm-energize-urls ()
  261.   ;; Don't search too long in large regions.  If the region is
  262.   ;; large, search just the head and the tail of the region since
  263.   ;; they tend to contain the interesting text.
  264.   (let ((search-limit vm-url-search-limit)
  265.     search-pairs n)
  266.     (if (and search-limit (> (- (point-max) (point-min)) search-limit))
  267.     (setq search-pairs (list (cons (point-min)
  268.                        (+ (point-min) (/ search-limit 2)))
  269.                  (cons (- (point-max) (/ search-limit 2))
  270.                        (point-max))))
  271.       (setq search-pairs (list (cons (point-min) (point-max)))))
  272.     (cond
  273.      (vm-xemacs-p
  274.       (let (e)
  275.     (map-extents (function
  276.               (lambda (e ignore)
  277.             (if (extent-property e 'vm-url)
  278.                 (delete-extent e))
  279.             nil))
  280.              (current-buffer) (point-min) (point-max))
  281.     (while search-pairs
  282.       (goto-char (car (car search-pairs)))
  283.       (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t)
  284.         (setq n 1)
  285.         (while (null (match-beginning n))
  286.           (vm-increment n))
  287.         (setq e (make-extent (match-beginning n) (match-end n)))
  288.         (set-extent-property e 'vm-url t)
  289.         (if vm-highlight-url-face
  290.         (set-extent-property e 'face vm-highlight-url-face))
  291.         (if vm-url-browser
  292.         (let ((keymap (make-sparse-keymap))
  293.               (popup-function
  294.                (if (save-excursion
  295.                  (goto-char (match-beginning n))
  296.                  (looking-at "mailto:"))
  297.                'vm-menu-popup-mailto-url-browser-menu
  298.              'vm-menu-popup-url-browser-menu)))
  299.           (define-key keymap 'button2 'vm-mouse-send-url-at-event)
  300.           (if vm-popup-menu-on-mouse-3
  301.               (define-key keymap 'button3 popup-function))
  302.           (define-key keymap "\r"
  303.             (function (lambda () (interactive)
  304.                 (vm-mouse-send-url-at-position (point)))))
  305.           (set-extent-property e 'keymap keymap)
  306.           (set-extent-property e 'balloon-help 'vm-url-help)
  307.           (set-extent-property e 'highlight t))))
  308.       (setq search-pairs (cdr search-pairs)))))
  309.      ((and vm-fsfemacs-p
  310.        (fboundp 'overlay-put))
  311.       (let (o-lists o p)
  312.     (setq o-lists (overlay-lists)
  313.           p (car o-lists))
  314.     (while p
  315.       (and (overlay-get (car p) 'vm-url)
  316.            (delete-overlay (car p)))
  317.       (setq p (cdr p)))
  318.     (setq p (cdr o-lists))
  319.     (while p
  320.       (and (overlay-get (car p) 'vm-url)
  321.            (delete-overlay (car p)))
  322.       (setq p (cdr p)))
  323.     (while search-pairs
  324.       (goto-char (car (car search-pairs)))
  325.       (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t)
  326.         (setq n 1)
  327.         (while (null (match-beginning n))
  328.           (vm-increment n))
  329.         (setq o (make-overlay (match-beginning n) (match-end n)))
  330.         (overlay-put o 'vm-url t)
  331.         (if vm-highlight-url-face
  332.         (overlay-put o 'face vm-highlight-url-face))
  333.         (if vm-url-browser
  334.         (let ((keymap (make-sparse-keymap))
  335.               (popup-function
  336.                (if (save-excursion
  337.                  (goto-char (match-beginning n))
  338.                  (looking-at "mailto:"))
  339.                'vm-menu-popup-mailto-url-browser-menu
  340.              'vm-menu-popup-url-browser-menu)))
  341.           (overlay-put o 'mouse-face 'highlight)
  342.           (setq keymap (nconc keymap (current-local-map)))
  343.           (if vm-popup-menu-on-mouse-3
  344.               (define-key keymap [mouse-3] popup-function))
  345.           (define-key keymap "\r"
  346.             (function (lambda () (interactive)
  347.                 (vm-mouse-send-url-at-position (point)))))
  348.           (overlay-put o 'local-map keymap))))
  349.       (setq search-pairs (cdr search-pairs))))))))
  350.  
  351. (defun vm-energize-headers ()
  352.   (cond
  353.    (vm-xemacs-p
  354.     (let ((search-tuples '(("^From:" vm-menu-author-menu)
  355.                ("^Subject:" vm-menu-subject-menu)))
  356.       regexp menu keymap e)
  357.       (map-extents (function
  358.             (lambda (e ignore)
  359.               (if (extent-property e 'vm-header)
  360.               (delete-extent e))
  361.               nil))
  362.            (current-buffer) (point-min) (point-max))
  363.       (while search-tuples
  364.     (goto-char (point-min))
  365.     (setq regexp (nth 0 (car search-tuples))
  366.           menu (symbol-value (nth 1 (car search-tuples))))
  367.     (while (re-search-forward regexp nil t)
  368.       (save-excursion (goto-char (match-beginning 0)) (vm-match-header))
  369.       (setq e (make-extent (vm-matched-header-contents-start)
  370.                    (vm-matched-header-contents-end)))
  371.       (set-extent-property e 'vm-header t)
  372.       (setq keymap (make-sparse-keymap))
  373.       ;; Might as well make button2 do what button3 does in
  374.       ;; this case, since there is no default 'select'
  375.       ;; action.
  376.       (define-key keymap 'button2
  377.         (list 'lambda () '(interactive)
  378.           (list 'popup-menu (list 'quote menu))))
  379.       (if vm-popup-menu-on-mouse-3
  380.           (define-key keymap 'button3
  381.         (list 'lambda () '(interactive)
  382.               (list 'popup-menu (list 'quote menu)))))
  383.       (set-extent-property e 'keymap keymap)
  384.       (set-extent-property e 'balloon-help 'vm-mouse-3-help)
  385.       (set-extent-property e 'highlight t))
  386.     (setq search-tuples (cdr search-tuples)))))
  387.    ((and vm-fsfemacs-p
  388.      (fboundp 'overlay-put))
  389.     (let ((search-tuples '(("^From:" vm-menu-fsfemacs-author-menu)
  390.                ("^Subject:" vm-menu-fsfemacs-subject-menu)))
  391.       regexp menu
  392.       o-lists o p)
  393.       (setq o-lists (overlay-lists)
  394.         p (car o-lists))
  395.       (while p
  396.     (and (overlay-get (car p) 'vm-header)
  397.          (delete-overlay (car p)))
  398.     (setq p (cdr p)))
  399.       (setq p (cdr o-lists))
  400.       (while p
  401.     (and (overlay-get (car p) 'vm-header)
  402.          (delete-overlay (car p)))
  403.     (setq p (cdr p)))
  404.       (while search-tuples
  405.     (goto-char (point-min))
  406.     (setq regexp (nth 0 (car search-tuples))
  407.           menu (symbol-value (nth 1 (car search-tuples))))
  408.     (while (re-search-forward regexp nil t)
  409.       (goto-char (match-end 0))
  410.       (save-excursion (goto-char (match-beginning 0)) (vm-match-header))
  411.       (setq o (make-overlay (vm-matched-header-contents-start)
  412.                 (vm-matched-header-contents-end)))
  413.       (overlay-put o 'vm-header menu)
  414.       (overlay-put o 'mouse-face 'highlight))
  415.     (setq search-tuples (cdr search-tuples)))))))
  416.  
  417. (defun vm-display-xface ()
  418.   (let ((case-fold-search t) e g h)
  419.     (if (map-extents (function
  420.               (lambda (e ignore)
  421.             (if (extent-property e 'vm-xface)
  422.                 t
  423.               nil)))
  424.              (current-buffer) (point-min) (point-max))
  425.     nil
  426.       (goto-char (point-min))
  427.       (if (find-face 'vm-xface)
  428.       nil
  429.     (make-face 'vm-xface)
  430.     (set-face-background 'vm-xface "white")
  431.     (set-face-foreground 'vm-xface "black"))
  432.       (if (re-search-forward "^X-Face:" nil t)
  433.       (progn
  434.         (goto-char (match-beginning 0))
  435.         (vm-match-header)
  436.         (setq h (concat "X-Face: " (vm-matched-header-contents)))
  437.         (setq g (intern h vm-xface-cache))
  438.         (if (boundp g)
  439.         (setq g (symbol-value g))
  440.           (set g (make-glyph
  441.               (list
  442.                (list 'global (cons '(tty) [nothing]))
  443.                (list 'global (cons '(win) (vector 'xface ':data h))))))
  444.           (setq g (symbol-value g))
  445.           ;; XXX broken.  Gives extra pixel lines at the
  446.           ;; bottom of the glyph in 19.12
  447.           ;;(set-glyph-baseline g 100)
  448.           (set-glyph-face g 'vm-xface))
  449.         (setq e (make-extent (vm-vheaders-of (car vm-message-pointer))
  450.                  (vm-vheaders-of (car vm-message-pointer))))
  451.         (set-extent-property e 'vm-xface t)
  452.         (set-extent-begin-glyph e g))))))
  453.  
  454. (defun vm-url-help (object)
  455.   (format
  456.    "Use mouse button 2 to send the URL to %s.
  457. Use mouse button 3 to choose a Web browser for the URL."
  458.    (cond ((stringp vm-url-browser) vm-url-browser)
  459.      ((eq vm-url-browser 'w3-fetch)
  460.       "Emacs W3")
  461.      ((eq vm-url-browser 'w3-fetch-other-frame)
  462.       "Emacs W3")
  463.      ((eq vm-url-browser 'vm-mouse-send-url-to-mosaic)
  464.       "Mosaic")
  465.      ((eq vm-url-browser 'vm-mouse-send-url-to-netscape)
  466.       "Netscape")
  467.      (t (symbol-name vm-url-browser)))))
  468.  
  469. (defun vm-energize-urls-in-message-region (&optional start end)
  470.   (save-excursion
  471.     (or start (setq start (vm-headers-of (car vm-message-pointer))))
  472.     (or end (setq end (vm-text-end-of (car vm-message-pointer))))
  473.     ;; energize the URLs
  474.     (if (or vm-highlight-url-face vm-url-browser)
  475.     (save-restriction
  476.       (widen)
  477.       (narrow-to-region start end)
  478.       (vm-energize-urls)))))
  479.     
  480. (defun vm-highlight-headers-maybe ()
  481.   ;; highlight the headers
  482.   (if (or vm-highlighted-header-regexp
  483.       (and vm-xemacs-p vm-use-lucid-highlighting))
  484.       (save-restriction
  485.     (widen)
  486.     (narrow-to-region (vm-headers-of (car vm-message-pointer))
  487.               (vm-text-end-of (car vm-message-pointer)))
  488.     (vm-highlight-headers))))
  489.  
  490. (defun vm-energize-headers-and-xfaces ()
  491.   ;; energize certain headers
  492.   (if (and vm-use-menus (vm-menu-support-possible-p))
  493.       (save-restriction
  494.     (widen)
  495.     (narrow-to-region (vm-headers-of (car vm-message-pointer))
  496.               (vm-text-of (car vm-message-pointer)))
  497.     (vm-energize-headers)))
  498.   ;; display xfaces, if we can
  499.   (if (and vm-display-xfaces
  500.        vm-xemacs-p
  501.        (featurep 'xface))
  502.       (save-restriction
  503.     (widen)
  504.     (narrow-to-region (vm-headers-of (car vm-message-pointer))
  505.               (vm-text-of (car vm-message-pointer)))
  506.     (vm-display-xface))))
  507.  
  508. (defun vm-narrow-for-preview ()
  509.   (widen)
  510.   ;; hide as much of the message body as vm-preview-lines specifies
  511.   (narrow-to-region
  512.    (vm-vheaders-of (car vm-message-pointer))
  513.    (cond ((not (eq vm-preview-lines t))
  514.       (min
  515.        (vm-text-end-of (car vm-message-pointer))
  516.        (save-excursion
  517.          (goto-char (vm-text-of (car vm-message-pointer)))
  518.          (forward-line (if (natnump vm-preview-lines) vm-preview-lines 0))
  519.          (point))))
  520.      (t (vm-text-end-of (car vm-message-pointer))))))
  521.  
  522. (defun vm-preview-current-message ()
  523.   (vm-save-buffer-excursion
  524.    (setq vm-system-state 'previewing
  525.      vm-mime-decoded nil)
  526.    (if vm-real-buffers
  527.        (vm-make-virtual-copy (car vm-message-pointer)))
  528.  
  529.    ;; run the message select hooks.
  530.    (save-excursion
  531.      (vm-select-folder-buffer)
  532.      (vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook)
  533.      (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer))
  534.       (vm-run-message-hook (car vm-message-pointer)
  535.                    'vm-select-new-message-hook))
  536.      (and vm-select-unread-message-hook
  537.       (vm-unread-flag (car vm-message-pointer))
  538.       (vm-run-message-hook (car vm-message-pointer)
  539.                    'vm-select-unread-message-hook)))
  540.  
  541.    (vm-narrow-for-preview)
  542.    (if (or vm-mime-display-function
  543.        (and vm-display-using-mime
  544.         (not (vm-mime-plain-message-p (car vm-message-pointer)))))
  545.        (let ((layout (vm-mm-layout (car vm-message-pointer))))
  546.      (vm-make-presentation-copy (car vm-message-pointer))
  547.      (vm-save-buffer-excursion
  548.       (vm-replace-buffer-in-windows (current-buffer)
  549.                     vm-presentation-buffer))
  550.      (set-buffer vm-presentation-buffer)
  551.      (setq vm-system-state 'previewing)
  552.      (vm-narrow-for-preview))
  553.      (setq vm-presentation-buffer nil)
  554.      (and vm-presentation-buffer-handle
  555.       (vm-replace-buffer-in-windows vm-presentation-buffer-handle
  556.                     (current-buffer))))
  557.  
  558.    ;; at this point the current buffer is the presentation buffer
  559.    ;; if we're using one for this message.
  560.  
  561.    (vm-unbury-buffer (current-buffer))
  562.    (vm-energize-urls-in-message-region)
  563.    (vm-highlight-headers-maybe)
  564.    (vm-energize-headers-and-xfaces)
  565.  
  566.    (if vm-honor-page-delimiters
  567.        (vm-narrow-to-page))
  568.    (goto-char (vm-text-of (car vm-message-pointer)))
  569.    ;; If we have a window, set window start appropriately.
  570.    (let ((w (vm-get-visible-buffer-window (current-buffer))))
  571.      (if w
  572.      (progn (set-window-start w (point-min))
  573.         (set-window-point w (vm-text-of (car vm-message-pointer))))))
  574.    (if (or (null vm-preview-lines)
  575.        (and (not vm-preview-read-messages)
  576.         (not (vm-new-flag (car vm-message-pointer)))
  577.         (not (vm-unread-flag (car vm-message-pointer)))))
  578.        (vm-show-current-message)
  579.      (vm-update-summary-and-mode-line))))
  580.  
  581. (defun vm-show-current-message ()
  582.   (and vm-display-using-mime
  583.        vm-auto-decode-mime-messages
  584.        (if vm-mail-buffer
  585.        (not (vm-buffer-variable-value vm-mail-buffer 'vm-mime-decoded))
  586.      (not vm-mime-decoded))
  587.        (not (vm-mime-plain-message-p (car vm-message-pointer)))
  588.        (condition-case data
  589.        (vm-decode-mime-message)
  590.      (vm-mime-error (vm-set-mime-layout-of (car vm-message-pointer)
  591.                            (car (cdr data)))
  592.             (message "%s" (car (cdr data))))))
  593.   (vm-save-buffer-excursion
  594.    (save-excursion
  595.      (save-excursion
  596.        (goto-char (point-min))
  597.        (widen)
  598.        (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer))))
  599.      (if vm-honor-page-delimiters
  600.      (progn
  601.        (if (looking-at page-delimiter)
  602.            (forward-page 1))
  603.        (vm-narrow-to-page))))
  604.    ;; don't mark the message as read if the user can't see it!
  605.    (if (vm-get-visible-buffer-window (current-buffer))
  606.        (progn
  607.      (save-excursion
  608.        (setq vm-system-state 'showing)
  609.        (if vm-mail-buffer
  610.            (vm-set-buffer-variable vm-mail-buffer 'vm-system-state
  611.                        'showing))
  612.        ;; We could be in the presentation buffer here.  Since
  613.        ;; the presentation buffer's message pointer and sole
  614.        ;; message are a mockup, they will cause trouble if
  615.        ;; passed into the undo/update system.  So we switch
  616.        ;; into the real message buffer to do attribute
  617.        ;; updates.
  618.        (vm-select-folder-buffer)
  619.        (cond ((vm-new-flag (car vm-message-pointer))
  620.           (vm-set-new-flag (car vm-message-pointer) nil)))
  621.        (cond ((vm-unread-flag (car vm-message-pointer))
  622.           (vm-set-unread-flag (car vm-message-pointer) nil))))
  623.      (vm-update-summary-and-mode-line)
  624.      (vm-howl-if-eom))
  625.      (vm-update-summary-and-mode-line))))
  626.  
  627. (defun vm-expose-hidden-headers ()
  628.   "Toggle exposing and hiding message headers that are normally not visible."
  629.   (interactive)
  630.   (vm-follow-summary-cursor)
  631.   (vm-select-folder-buffer)
  632.   (vm-check-for-killed-summary)
  633.   (vm-check-for-killed-presentation)
  634.   (vm-error-if-folder-empty)
  635.   (and vm-presentation-buffer
  636.        (set-buffer vm-presentation-buffer))
  637.   (vm-display (current-buffer) t '(vm-expose-hidden-headers)
  638.           '(vm-expose-hidden-headers reading-message))
  639.   (let* ((exposed (= (point-min) (vm-start-of (car vm-message-pointer)))))
  640.     (vm-widen-page)
  641.     (goto-char (point-max))
  642.     (widen)
  643.     (if exposed
  644.     (narrow-to-region (point) (vm-vheaders-of (car vm-message-pointer)))
  645.       (narrow-to-region (point) (vm-start-of (car vm-message-pointer))))
  646.     (goto-char (point-min))
  647.     (let (w)
  648.       (setq w (vm-get-visible-buffer-window (current-buffer)))
  649.       (and w (set-window-point w (point-min)))
  650.       (and w
  651.        (= (window-start w) (vm-vheaders-of (car vm-message-pointer)))
  652.        (not exposed)
  653.        (set-window-start w (vm-start-of (car vm-message-pointer)))))
  654.     (if vm-honor-page-delimiters
  655.     (vm-narrow-to-page))))
  656.  
  657. (defun vm-widen-page ()
  658.   (if (or (> (point-min) (vm-text-of (car vm-message-pointer)))
  659.       (/= (point-max) (vm-text-end-of (car vm-message-pointer))))
  660.       (narrow-to-region (vm-vheaders-of (car vm-message-pointer))
  661.             (if (or (vm-new-flag (car vm-message-pointer))
  662.                 (vm-unread-flag (car vm-message-pointer)))
  663.                 (vm-text-of (car vm-message-pointer))
  664.               (vm-text-end-of (car vm-message-pointer))))))
  665.  
  666. (defun vm-narrow-to-page ()
  667.   (save-excursion
  668.     (let (min max (omin (point-min)) (omax (point-max)))
  669.       (if (or (bolp) (not (save-excursion
  670.                 (beginning-of-line)
  671.                 (looking-at page-delimiter))))
  672.       (forward-page -1))
  673.       (setq min (point))
  674.       (forward-page 1)
  675.       (beginning-of-line)
  676.       (setq max (point))
  677.       (narrow-to-region min max))))
  678.  
  679. (defun vm-beginning-of-message ()
  680.   "Moves to the beginning of the current message."
  681.   (interactive)
  682.   (vm-follow-summary-cursor)
  683.   (vm-select-folder-buffer)
  684.   (vm-check-for-killed-summary)
  685.   (vm-check-for-killed-presentation)
  686.   (vm-error-if-folder-empty)
  687.   (and vm-presentation-buffer
  688.        (set-buffer vm-presentation-buffer))
  689.   (vm-widen-page)
  690.   (push-mark)
  691.   (vm-display (current-buffer) t '(vm-beginning-of-message)
  692.           '(vm-beginning-of-message reading-message))
  693.   (let ((osw (selected-window)))
  694.     (unwind-protect
  695.     (progn
  696.       (select-window (vm-get-visible-buffer-window (current-buffer)))
  697.       (goto-char (point-min)))
  698.       (if (not (eq osw (selected-window)))
  699.       (select-window osw))))
  700.   (if vm-honor-page-delimiters
  701.       (vm-narrow-to-page)))
  702.  
  703. (defun vm-end-of-message ()
  704.   "Moves to the end of the current message, exposing and flagging it read
  705. as necessary."
  706.   (interactive)
  707.   (vm-follow-summary-cursor)
  708.   (vm-select-folder-buffer)
  709.   (vm-check-for-killed-summary)
  710.   (vm-check-for-killed-presentation)
  711.   (vm-error-if-folder-empty)
  712.   (and vm-presentation-buffer
  713.        (set-buffer vm-presentation-buffer))
  714.   (if (eq vm-system-state 'previewing)
  715.       (vm-show-current-message))
  716.   (setq vm-system-state 'reading)
  717.   (vm-widen-page)
  718.   (push-mark)
  719.   (vm-display (current-buffer) t '(vm-end-of-message)
  720.           '(vm-end-of-message reading-message))
  721.   (let ((osw (selected-window)))
  722.     (unwind-protect
  723.     (progn
  724.       (select-window (vm-get-visible-buffer-window (current-buffer)))
  725.       (goto-char (point-max)))
  726.       (if (not (eq osw (selected-window)))
  727.       (select-window osw))))
  728.   (if vm-honor-page-delimiters
  729.       (vm-narrow-to-page)))
  730.